unit QExport4XML;

{$I QExport4VerCtrl.inc}

interface

uses QExport4, Classes, QExport4Types;

type
  TQExportXMLType = (xtDatapacket2, xtAccess);

  TQXMLWriter = class(TQExportWriter)
  public
    procedure StartTag(const TagName, Options: QEString);
    procedure EndTag(const TagName: QEString);
    procedure StartEndTag(const TagName, Options: QEString);
    procedure StartTagLn(const TagName, Options: QEString);
    procedure EndTagLn(const TagName: QEString);
    procedure StartEndTagLn(const TagName, Options: QEString);
  end;

  TXMLOptions = class(TPersistent)
  private
    FStandAlone: Boolean;
    FEncoding: string;
    FVersion: string;
  public
    constructor Create;
    procedure Assign(Source: TPersistent); override;
  published
    property Version: string read FVersion write FVersion;
    property Encoding: string read FEncoding write FEncoding;
    property StandAlone: boolean read FStandAlone write FStandAlone default true;
  end;

  TQExport4XML = class(TQExport4Text)
  private
    FOptions: TXMLOptions;
    FDocumentType: TQExportXMLType;
    FExportXSDSchema: Boolean;
    FCorrectNames: TStrings;
    FModifiedCaption: array of Boolean;

    procedure SetOptions(const Value: TXMLOptions);
    procedure CreateSchema;
    function GetTableName: QEString;
  protected
    procedure BeginExport; override;
    procedure BeforeExport; override;
    function GetColCaption(Index: integer): string; override;
    procedure WriteCaptionRow; override;
    function GetDataRow: QEString; override;
    procedure WriteDataRow; override;
    procedure AfterExport; override;
    {//mp - procedure for forming correct captions}
    procedure FormCorrectCaptions;

    function GetSpecialCharacters: TSpecialCharacters; override;

    function GetWriter: TQXMLWriter;
    function GetWriterClass: TQExportWriterClass; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    
    function NormalString(const S: QEString): QEString; override;
  published
    property Options: TXMLOptions read FOptions write SetOptions;
    property Captions;
    property UserFormats;
    property DocumentType: TQExportXMLType read FDocumentType
      write FDocumentType default xtDatapacket2;
    property ExportXSDSchema: Boolean read FExportXSDSchema
      write FExportXSDSchema default False;
  end;

implementation

uses
  SysUtils, {$IFDEF VCL6}StrUtils,{$ENDIF} QExport4Common,
  QExport4EmsWideStrUtils{$IFDEF MSWINDOWS}, Windows{$ENDIF};

const
  SYes = 'yes';
  SNo  = 'no';
  SEncoding  = 'encoding="%s" ';
  SStartXML  = '<?xml version="%s" %sstandalone="%s"?>';
  SStartData = '<DATAPACKET Version="2.0">';
  SEndData   = '</DATAPACKET>';
  SMetaData  = 'METADATA';
  SFields    = 'FIELDS';
  SRowData   = 'ROWDATA';

  SRow          = 'ROW';
  SRowField     = '%s="%s"';
  SField        = 'FIELD';
  SFieldName    = 'FieldName="%s"';
  SDisplayLabel = 'DisplayLabel="%s"';
  SFieldType    = 'FieldType="%s"';
  SFieldClass   = 'FieldClass="%s"';

  STagB = '<';
  STagE = '>';
  STagC = '/';
  SEqual = '=';
  SBlank = ' ';

  //xtAccess
  SAStartData = 'dataroot xmlns:od="urn:schemas-microsoft-com:officedata"';
  SAXSDSchema = 'xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xsi:noNamespaceSchemaLocation'; 
  SAEndData = '</dataroot>';

  //XSD Schema
  SStartElementDataroot = '<xsd:schema xmlns:xsd="http://www.w3.org/2001/XMLSchema" xmlns:od="urn:schemas-microsoft-com:officedata">' +
    '<xsd:element name="dataroot">' +
    '<xsd:complexType>' +
    '<xsd:sequence>';
  SStartElementTable = '<xsd:element ref="';
  SEndElementTable = '" minOccurs="0" maxOccurs="unbounded"/>';
  SEndElementDataroot = '</xsd:sequence>' +
    '<xsd:attribute name="generated" type="xsd:dateTime"/>' +
    '</xsd:complexType>' +
    '</xsd:element>';

  SXSDElement = 'xsd:element';
  SXSDSchema = 'xsd:schema';
  SXSDAnnotation = 'xsd:annotation';
  SXSDAppinfo = 'xsd:appinfo';
  SXSDComplexType = 'xsd:complexType';
  SXSDSequence = 'xsd:sequence';

  {//mp - list of correct symbols, which can be used for names of xml fields}
  CorrectSymbols = ['a'..'z', 'A'..'Z', '0'..'9', '-', '_', '.', ':'];

{ TQXMLWriter }

procedure TQXMLWriter.EndTag(const TagName: QEString);
begin
  Write(STagB +  STagC + TagName + STagE);
end;

procedure TQXMLWriter.EndTagLn(const TagName: QEString);
begin
  EndTag(TagName);
  EmptyLine;
end;

procedure TQXMLWriter.StartEndTag(const TagName, Options: QEString);
begin
  Write(STagB + TagName + ' ' + Options + STagC + STagE);
end;

procedure TQXMLWriter.StartEndTagLn(const TagName, Options: QEString);
begin
  StartEndTag(TagName, Options);
  EmptyLine;
end;

procedure TQXMLWriter.StartTag(const TagName, Options: QEString);
begin
  if Options <> EmptyStr then Write(STagB + TagName + ' ' + Options + STagE)
  else Write(STagB + TagName + STagE);
end;

procedure TQXMLWriter.StartTagLn(const TagName, Options: QEString);
begin
  StartTag(TagName, Options);
  EmptyLine;
end;

{ TXMLOptions }

procedure TXMLOptions.Assign(Source: TPersistent);
begin
  if Source is TXMLOptions then begin
    StandAlone := (Source as TXMLOptions).StandAlone;
    Encoding := (Source as TXMLOptions).Encoding;
    Version := (Source as TXMLOptions).Version;
    Exit;
  end;
  inherited;
end;

constructor TXMLOptions.Create;
begin
  inherited;
  FStandAlone := true;
  FVersion := '1.0';
  FEncoding := EmptyStr;
end;

{function StringReplace(const S, OldPattern, NewPattern: string;
  Flags: TReplaceFlags): string;
var
  SearchStr, Patt, NewStr: string;
  Offset: Integer;
begin
  if rfIgnoreCase in Flags then
  begin
    SearchStr := AnsiUpperCase(S);
    Patt := AnsiUpperCase(OldPattern);
  end else
  begin
    SearchStr := S;
    Patt := OldPattern;
  end;}

{ TQExport4XML }

procedure TQExport4XML.SetOptions(const Value: TXMLOptions);
begin
  FOptions.Assign(Value);
end;

procedure TQExport4XML.CreateSchema;

  function GetTag(Name: QEString;
    Start: Boolean; AText: QEString = ''): QEString;
  begin
    if Start then
      Result := STagB + Name
    else
      Result := STagB + STagC + Name;
      
    Result := Result + SBlank + AText + STagE;
  end;

  function GetFieldType(ColType: TQExportColType): QEString;
  begin
    case ColType of
      ectInteger, ectBigint:
        Result := 'minOccurs="0" od:jetType="longinteger" od:sqlSType="int" type="xsd:int"';
      ectFloat, ectCurrency:
        Result := 'minOccurs="0" od:jetType="currency" od:sqlSType="money" type="xsd:double"';
      ectDate, ectTime, ectDateTime:
        Result := 'minOccurs="0" od:jetType="datetime" od:sqlSType="datetime" type="xsd:dateTime"';
      ectString:
        Result := 'minOccurs="0" od:jetType="text" od:sqlSType="nvarchar"';
      ectBoolean:
        Result := 'minOccurs="1" od:jetType="yesno" od:sqlSType="bit" od:nonNullable="yes" type="xsd:boolean"';
    else
      Result := 'minOccurs="0" od:jetType="text" od:sqlSType="nvarchar"';
    end;
  end;                    

var
  SchemaBody: QEString;
  Stream: TFileStream;
  Writer: TQXMLWriter;
  i: Integer;
begin
  Stream := TFileStream.Create(ChangeFileExt(FileName, '.xsd'), fmCreate);
  try
    Writer := TQXMLWriter.Create(Self, Stream);
    try
      SchemaBody := '<?xml version="1.0" encoding="UTF-8"?>';
      SchemaBody := SchemaBody + SStartElementDataroot + SStartElementTable + GetTableName +
        SEndElementTable + SEndElementDataroot;

      //table options
      SchemaBody := SchemaBody + GetTag(SXSDElement, True, 'name="' + GetTableName + '"');
      SchemaBody := SchemaBody + GetTag(SXSDAnnotation, True) + GetTag(SXSDAppinfo, True);
      //data od:tableProperty is not necessary
      SchemaBody := SchemaBody + GetTag(SXSDAppinfo, False) + GetTag(SXSDAnnotation, False) +
        GetTag(SXSDComplexType, True) + GetTag(SXSDSequence, True);

      for i := 0 to Columns.Count - 1 do
      begin
        SchemaBody := SchemaBody + GetTag(SXSDElement, True,
          'name="' + Columns[i].Name + '" ' + GetFieldType(Columns[i].ColType));
        SchemaBody := SchemaBody + GetTag(SXSDAnnotation, True) + GetTag(SXSDAppinfo, True);
        //data od:fieldProperty is not necessary
        SchemaBody := SchemaBody + GetTag(SXSDAppinfo, False) + GetTag(SXSDAnnotation, False) +
          GetTag(SXSDElement, False);
      end;

      SchemaBody := SchemaBody + GetTag(SXSDSequence, False) +
        GetTag(SXSDComplexType, False) + GetTag(SXSDElement, False) + GetTag(SXSDSchema, False);
      Writer.Write(SchemaBody);
    finally
      Writer.Free;
    end;
  finally
    Stream.Free;
  end;
end;

function TQExport4XML.GetTableName: QEString;
begin
  Result := ChangeFileExt(ExtractFileName(FileName), '');
end;

constructor TQExport4XML.Create(AOwner: TComponent);
begin
  inherited;
  FOptions := TXMLOptions.Create;
  DocumentType := xtDatapacket2;
  FExportXSDSchema := False;
  FCorrectNames := TStringList.Create;
end;

destructor TQExport4XML.Destroy;
begin
  FCorrectNames.Free;
  FOptions.Free;
  inherited;
end;

procedure TQExport4XML.BeginExport;
var
  sStandAlone, sEnc, sAccessStart: string;
begin
  inherited;
  FCorrectNames.Clear;
  FormCorrectCaptions;
  if FOptions.StandAlone then sStandAlone := SYes
  else sStandAlone := sNo;
  if FOptions.Encoding <> EmptyStr then sEnc := Format(SEncoding, [FOptions.Encoding])
  else sEnc := EmptyStr;
  GetWriter.WriteLn(Format(SStartXML, [FOptions.Version, sEnc, sStandAlone]));

  if FExportXSDSchema then CreateSchema;
  case FDocumentType of
    xtDatapacket2:
      GetWriter.WriteLn(SStartData);
    xtAccess:
    begin
      sAccessStart := STagB + SAStartData;
      if FExportXSDSchema then
        sAccessStart := sAccessStart + SBlank + SAXSDSchema + '="' + ChangeFileExt(ExtractFileName(FileName), '.xsd') +'"' + STagE
      else
        sAccessStart := sAccessStart + STagE;
      GetWriter.WriteLn(sAccessStart);
    end;
  end;
end;

procedure TQExport4XML.BeforeExport;
begin
  case FDocumentType of
    xtDatapacket2:
      GetWriter.StartTagLn(SRowData, EmptyStr);
  end;
end;

function TQExport4XML.GetColCaption(Index: integer): string;
var
  FName: string;
  FDisplay: string;
begin
  case FDocumentType of
    xtDatapacket2:
      begin
        {FName := StringReplace(Columns[Index].Name, ' ', '_', [rfReplaceAll, rfIgnoreCase]);}
        {mp - new string}
        FName := FCorrectNames[Index];
        Result := Format(SFieldName, [FName]) + SBlank;
        FDisplay := NormalString(StringReplace(
          Columns[Index].Caption, ' ', '_', [rfReplaceAll, rfIgnoreCase]));
//dee          Columns[Index].Name, ' ', '_', [rfReplaceAll, rfIgnoreCase]));
        {mp - Check name displaying here - if some bugs will happen}
        {then change FDisplay variable to FName in next string}
        {it will be full compitable}
        Result := Result + Format(SDisplayLabel, [FDisplay]) + SBlank;
        Result := Result + Format(SFieldType,
          [QExportColTypeAsString(Columns[Index].ColType)]) + SBlank;
        Result := Result + Format(SFieldClass, ['TField']);
      end;
  end;
end;

procedure TQExport4XML.WriteCaptionRow;
var
  i: integer;
begin
  case FDocumentType of
    xtDatapacket2:
      begin
        GetWriter.StartTagLn(SMetaData, EmptyStr);
        GetWriter.StartTagLn(SFields, EmptyStr);

        for i := 0 to Columns.Count - 1 do
          GetWriter.StartEndTagLn(SField, GetColCaption(i));

        GetWriter.EndTagLn(SFields);
        GetWriter.EndTagLn(SMetaData);
      end;
  end;
end;

function TQExport4XML.GetDataRow: QEString;
var
  i: integer;
begin
  Result := EmptyStr;
  case FDocumentType of
    xtDatapacket2:
      begin
        for i := 0 to ExportRow.Count - 1 do
          Result := Result + {QEStringReplace(ExportRow[i].Name, ' ', '_', [rfReplaceAll, rfIgnoreCase]) +}
            FCorrectNames[i] +
            '="' + GetExportedValue(ExportRow[i]) + '"' + SBlank;
      {  for i := 0 to Columns.Count - 1 do
          Result := Result + Format(sRowField, [Columns[i].Name, GetColData(i, NeedFormat)]) + SBlank;}
        QEDelete(Result, Length(Result), 1);
      end;
    xtAccess:
      begin
        Result := STagB + GetTableName + STagE;
        for i := 0 to ExportRow.Count - 1 do
        begin
          if Columns.Count > i then
            Result := Result + STagB + Columns[i].Name + STagE +
              GetExportedValue(ExportRow[i]) + STagB + STagC + Columns[i].Name + STagE;
        end;
        Result := Result + STagB + STagC + GetTableName + STagE;
      end;
  end;
end;

procedure TQExport4XML.WriteDataRow;
begin
  case FDocumentType of
    xtDatapacket2:
        GetWriter.StartEndTagLn(SRow, GetDataRow);
    xtAccess:
        GetWriter.WriteLn(GetDataRow);
  end;
end;

procedure TQExport4XML.AfterExport;
begin
  case FDocumentType of
    xtDatapacket2:
      begin
        GetWriter.EndTagLn(SRowData);
        GetWriter.WriteLn(SEndData);
      end;
    xtAccess:
      begin
        GetWriter.WriteLn(SAEndData);
      end;
  end;
  
  inherited;
end;

function TQExport4XML.GetSpecialCharacters: TSpecialCharacters;
begin
  Result := ['<', '>', '&', '"'];
end;

function TQExport4XML.GetWriter: TQXMLWriter;
begin
  Result := TQXMLWriter(inherited GetWriter);
end;

function TQExport4XML.GetWriterClass: TQExportWriterClass;
begin
  Result := TQXMLWriter;
end;

function TQExport4XML.NormalString(const S: QEString): QEString;
var
  i, p: integer;
const
  SearchSym: array [0..4] of WideString = ('&', '>', '<', '"', ' ');
  ReplSym: array [0..4] of WideString = ('&amp;', '&gt;', '&lt;', '&quot;', '&#160;');
begin
  Result := S;
  for i := 0 to Length(SearchSym) - 1 do
  begin
    p := 1;
    while p > 0 do
    begin
      p := QEPosEx(SearchSym[i], Result, p);
      if p > 0 then
      begin
        QEDelete(Result, p, 1);
        QEInsert(ReplSym[i], Result, p);
        Inc(p, 4);
      end;
    end;
  end;
end;

{mp - this code is not Unicode yet}
{because Field names aren't unicode in base}
{full correct symbols array can be found in}
{http://www.w3.org/TR/REC-xml in Part B Character Classes}
procedure TQExport4XML.FormCorrectCaptions;
var
  i: integer;
  Generator: integer;
  Temp: string;

  {common function for caption normalization}
  function NormalCaption(Name: string; Number: Integer): string;
  var
    Iter: integer;
  begin
    Result := Name;
    Iter := 1;
    while true do
    begin
      if Iter > Length(Result) then
        break;
      if not QExport4Common.CharInSet(Result[Iter], CorrectSymbols) then
      begin
        {Set modified to true - this caption could be involved}
        {into id generation processes}
        FModifiedCaption[Number] := true;
        Delete(Result, Iter, 1);
        {Check for multiple _ sequnce - if exists - then just removing}
        if Iter = 1 then
          if (Length(Result) = 0) or ((Result[Iter] <> '_')
            and QExport4Common.CharInSet(Result[Iter], CorrectSymbols)) then
          begin
            Insert('_', Result, Iter);
            Iter := Iter + 1;
            continue;
          end;
        if (Iter - 1) = Length(Result) then
          if (Length(Result) = 0) or ((Result[Iter - 1] <> '_')
            and QExport4Common.CharInSet(Result[Iter - 1], CorrectSymbols)) then
          begin
            Insert('_', Result, Iter);
            Iter := Iter + 1;
            continue;
          end;
        if (Iter > 1) and ((Iter - 1) < Length(Result))
            and (Result[Iter - 1] <> '_')
            and (Result[Iter] <> '_')
            and QExport4Common.CharInSet(Result[Iter], CorrectSymbols)
            and (QExport4Common.CharInSet(Result[Iter - 1], CorrectSymbols)) then
          begin
            Insert('_', Result, Iter);
            Iter := Iter + 1;
            continue;
          end;
        Iter := Iter - 1;
      end;
      Iter := Iter + 1;
    end;
  end;

  {Routine for searching equal names}
  function CheckInCurrentList(SearchString: string;
    CurrentNumber: integer): Boolean;
  var
    i: Integer;
  begin
    Result := false;
    for i := 0 to FCorrectNames.Count - 1 do
      if (i <> CurrentNumber) and
        (AnsiCompareStr(SearchString, FCorrectNames[i]) = 0) then
        begin
          Result := true;
          Break;
        end;
  end;

begin
  {Forming new caption array with correct xml names}
  {and forming new bool array for modified captions}
  SetLength(FModifiedCaption, Columns.Count);
  for i := 0 to Columns.Count - 1 do
  begin
    FModifiedCaption[i] := false;
    FCorrectNames.Add(NormalCaption(Columns[i].Name, i));
  end;
  {Looking for equal names in array}
  {If matches found - then generate new number}
  for i := 0 to Columns.Count - 1 do
  begin
    Generator := 1;
    if not FModifiedCaption[i] then
      continue;
    if AnsiCompareStr(FCorrectNames[i], '_') <> 0 then
      Temp := FCorrectNames[i]
    else
      Temp := SField + FCorrectNames[i] + IntToStr(Generator);
    {Routine for generating distinct names in caption rows}
    {If the string looks like '_' - it have to be changed into 'FIELD_1' etc}
    while CheckInCurrentList(Temp, i) do
    begin
      if AnsiCompareStr(FCorrectNames[i], '_') <> 0 then
        Temp := FCorrectNames[i] + IntToStr(Generator)
      else
        Temp := SField + FCorrectNames[i] + IntToStr(Generator);
      Generator := Generator + 1;
    end;
    if AnsiCompareStr(Temp, FCorrectNames[i]) <> 0 then
      FCorrectNames[i] := Temp;
  end;
end;

end.
